home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Contrib / STk-wtour / lib / wtour.stk < prev   
Encoding:
Text File  |  1996-06-07  |  12.2 KB  |  407 lines
  1. #!/bin/sh
  2. :;exec /usr/local/bin/stk -f 
  3. ;;
  4. ;;  STk/Scheme widget tour, Version 0.2
  5. ;;
  6. ;;  Originally for Tk/Tcl by:  Andrew Payne  payne@crl.dec.com
  7. ;;  This one simplified and redesigned for STk/Scheme 
  8. ;;  by: Suresh Srinivas ssriniva@cs.indiana.edu
  9.  
  10. ;; Main differences are in the way the demo window is created
  11. ;; The Tk/Tcl version uses send mechanisms extensively.
  12. ;; The STk/Scheme version avoids using send mechanisms and
  13. ;; fixes the user's input so as to make the user widgets to
  14. ;; be children of a top-level widget called .wtour-wdemo
  15.  
  16.  
  17. (option 'add "Tk.geometry"  "+25+405" "startupFile")
  18. (option 'add "Tk.demo-geometry" "300x300+25+25" "startupFile")
  19.  
  20. (option 'add "*Entry*BorderWidth"   "2")
  21. (option 'add "*Entry*Background"    "white")
  22. (option 'add "*Entry*Relief"        "sunken")
  23. (option 'add "*Entry*Font"          "-*-courier-bold-r-*-*-14-*-*-*-*-*-*-*")
  24. (option 'add "*Entry*Width"         "40")
  25.  
  26. ;; prefix all the globals with wtour
  27. ;; so that we dont screw up the global name space quite a lot
  28.  
  29. (define wtour-wdemo       ".wtour-wdemo")
  30. (define wtour-filename    #f)
  31. (define wtour-action      #f)
  32.  
  33. (define wtour-mframe      #f)
  34. (define wtour-txt         #f)
  35.  
  36. (define wtour-maxlessons  100)
  37. (define wtour-nlessons    #f)
  38. (define wtour-lessons     (make-vector wtour-maxlessons))
  39. (define wtour-curlesson   #f)
  40. (define wtour-dir      (if (null? *argv*) "." (car *argv*)))
  41. (define wtour-lessondir   (string-append wtour-dir "/lessons/"))
  42.  
  43. (define wtour-menus       '())
  44. (define wtour-menu-bar    '())
  45.  
  46.  
  47. ;; some tk goodies (stolen from one of the STk demos)
  48.  
  49. (define (->string obj)
  50.   (cond ((string? obj)     obj)
  51.         ((number? obj)     (number->string obj))
  52.         ((symbol? obj)     (symbol->string obj))
  53.         ((tk-command? obj) (widget->string obj))
  54.         (else              (error "Cannot convert ~S to a string" obj))))
  55.   
  56. (define (& . l)
  57.   (let loop ((l l) (s ""))
  58.     (if (null? l)
  59.         s
  60.         (loop (cdr l) (string-append s (->string (car l)))))))
  61.  
  62.  
  63.  
  64.  
  65. ;; Make a text widget with an attached scrollbar
  66. (define (mktext w)
  67.   (let ((scl #f)
  68.     (txt #f))
  69.     (frame w)
  70.     (set! scl (scrollbar (& w ".scroll")
  71.              :relief  "flat" 
  72.              :command (lambda l
  73.                     (apply txt 'yview l))))
  74.     (set! txt (text (& w ".text")    
  75.             :bd 1 
  76.             :relief "raised" 
  77.             :yscrollcommand (lambda l
  78.                       (apply scl 'set l))))
  79.     (pack scl :side "right" :fill "y")
  80.     (pack txt :expand #t :fill "both")
  81.     txt))
  82.  
  83. ;; Set up the demo window
  84. (begin
  85.   (catch (destroy .wtour-wdemo))
  86.   (toplevel wtour-wdemo)
  87.   (wm 'geometry wtour-wdemo "+300+300")
  88.   (wm 'minsize wtour-wdemo "100" "100")
  89.   (wm 'title .wtour-wdemo "STk Demo Window")
  90.   (wm 'iconname .wtour-wdemo "STk Demo Window")
  91.   (update "idletasks"))
  92.  
  93.  
  94. ;;
  95. ;;  Set up main window
  96. ;;
  97.  
  98. (wm 'title "." "STk Widget Tour")
  99.  
  100. (set! wtour-mframe (frame ".menu" :relief "raised" :borderwidth "1"))
  101. (pack wtour-mframe :fill "x")
  102.  
  103. ;; having to eval the return values from Tk is indeed a bother
  104.  
  105. (let ([mframe-help (& wtour-mframe ".help")]
  106.       [mframe-file (& wtour-mframe ".file")])
  107.   (let ([mframe-help-menu (& mframe-help ".menu")])
  108.     (menubutton mframe-help :text "Help" :menu mframe-help-menu)
  109.     (pack mframe-help :side "right")
  110.     (let ([m (menu mframe-help-menu)])
  111.       (m 'add 'command :label "Help!" :command '(mkHelp))))
  112.   (let ([mframe-file-menu (& mframe-file ".menu")])
  113.     (menubutton mframe-file :text "File" :menu mframe-file-menu)
  114.     (pack mframe-file :side "left")
  115.     (let ([m (menu mframe-file-menu)])
  116.       (m 'add 'command :label "New" :command '(do-new))
  117.       (m 'add 'command :label "Open..." :command '(do-open))
  118.       (m 'add 'command :label "Save..." :command '(do-saveas))
  119.       (m 'add 'separator)
  120.       (let ([mframe-file-menu-fonts (& mframe-file-menu ".fonts")])
  121.     (m 'add 'cascade :label "Screen Font" :menu mframe-file-menu-fonts)
  122.     (m 'add 'separator)
  123.     (m 'add 'command :label "Exit" :command '(do-exit))
  124.     (let ([m (menu mframe-file-menu-fonts)])
  125.           (m 'add 'command :label "Small" :command 
  126.              '(set-font "-*-courier-medium-r-*-*-12-*-*-*-*-*-*-*"))
  127.           (m 'add 'command :label "Medium" :command 
  128.              '(set-font "-*-courier-medium-r-*-*-14-*-*-*-*-*-*-*"))
  129.           (m 'add 'command :label "Large" :command 
  130.              '(set-font "-*-courier-medium-r-*-*-18-*-*-*-*-*-*-*")))))))
  131.  
  132.  
  133. (set! wtour-txt (mkText ".text"))
  134. (pack .text :expand "yes" :fill "both")
  135.  
  136. (bind wtour-txt "<Any-Key-Menu>"  (lambda () (apply-changes)))
  137. (bind wtour-txt "<Any-Key-Prior>" (lambda () (adjust-lesson -1)))
  138. (bind wtour-txt "<Any-Key-Next>"  (lambda () (adjust-lesson +1)))
  139. (focus wtour-txt)
  140.  
  141. (let ([f (frame ".buttons" :relief "raised" :borderw "1")])
  142.   (pack f :side "bottom" :fill "x")
  143.   (let ([f-apply (& f ".apply")]
  144.     [f-next  (& f ".next")]
  145.     [f-prev  (& f ".prev")])
  146.     (button f-apply :text " Apply " :command (lambda () (apply-changes)))
  147.     (button f-next  :text " Next  " :command (lambda () (adjust-lesson +1)))
  148.     (button f-prev  :text " Prev  " :command (lambda () (adjust-lesson -1)))
  149.     (pack f-apply f-next f-prev :side "left" :padx 7 :pady 7)))
  150.  
  151. ;;
  152. ;;  Set the font of both text windows
  153. ;;
  154.  
  155. (define (set-font reg)
  156.   (wtour-txt 'configure :font reg))
  157.  
  158.  
  159. ;;  Make a new dialog toplevel window
  160. ;;
  161.  
  162. (define (mkDialogWindow w)
  163.   (catch (destroy w))
  164.   (toplevel w :class "Dialog" :bd 0)
  165.   (wm 'title w "Dialog box")
  166.   (wm 'iconname w "Dialog")
  167.   (wm 'geometry w "+425+300")
  168.   (grab w)
  169.   (focus w)
  170.   (string->symbol w))
  171.  
  172. (define (centerwindow w)
  173.   (wm 'withdraw w)
  174.   (update "idletasks")
  175.   (let ([x (- ( - (inexact->exact (/ (winfo 'screenwidth w) 2))
  176.           (inexact->exact (/ (winfo 'reqwidth w) 2)))
  177.           (winfo 'vrootx (eval (winfo 'parent w))))]
  178.     [y (- ( - (inexact->exact (/ (winfo 'screenheight w) 2))
  179.           (inexact->exact (/ (winfo 'reqheight w) 2)))
  180.           (winfo 'vrooty (eval (winfo 'parent w))))])
  181.     (wm 'geom w (format #f "+~A+~A" x y))
  182.     (wm 'deiconify w)))
  183.  
  184. (define (mkHelp)
  185.   (let ([w (mkDialogWindow ".help")])
  186.     (wm 'title w "Window Tour Help")
  187.     (let ([w-t (& w ".t")]
  188.       [w-f (& w ".buttons")])
  189.       (let ([t (mkText w-t)])
  190.     (pack w-t)
  191.     (let ([f (frame w-f :relief "raised" :borderw "1")])
  192.       (pack f :side "bottom" :fill "x")
  193.       (let ([f-close (& w-f ".close")])
  194.         (button f-close :text " Close " :command `(destroy ,w))
  195.         (pack f-close :side "right" :padx "7" :pady "7")))
  196.     (t 'insert "current"
  197. "Wtour is an interactive tour of STk widgets.
  198.  
  199. The main window displays a short Scheme/STk program, and the demo window
  200. displays the results of running the program.
  201.  
  202. You can make changes to the program and apply those changes by clicking
  203. on the \"Apply\" button or pressing the \"Do\" button.
  204.  
  205. You can navigate through the tour with the \"Prev\" and \"Next\" buttons.  Or,
  206. you can go directly to a specified lesson with the drop down menus.
  207.  
  208. There is also a command window that can be used to send individual commands
  209. to the demo process.  You can toggle the command window on and off with an
  210. option under the \"File\" menu.
  211.  
  212. Originally by: Andrew Payne (payne@crl.dec.com)
  213. STk rewrite by: Suresh Srinivas (ssriniva@cs.indiana.edu)
  214. STk 3.0 port by: Erick Gallesio (eg@unice.fr)")
  215.     (t 'configure :state "disabled")
  216.     (centerwindow w)))))
  217.  
  218.  
  219. ;; Make a one-line query dialog box
  220.  
  221. (define (mkentryquery w prompt var)
  222.   (let ([w (mkdialogwindow w)])
  223.     (let ([w-top (& w ".top")]
  224.       [w-bot (& w ".bot")])
  225.       (let ([t (frame w-top :relief "raised" :border "1")]
  226.         [b (frame w-bot :relief "raised" :border "1")])
  227.     (pack t b :fill "both")
  228.     (let ([t-lab     (& t ".lab")]
  229.           [t-ent     (& t ".ent")]
  230.           [b-ok      (& b ".ok")]
  231.           [b-default (& b ".default")]
  232.           [b-cancel  (& b ".cancel")])
  233.       (label t-lab :text prompt)
  234.       (let ([e (entry t-ent :textvar `,var)])
  235.         (bind e "<Any-Return>" `(set! wtour-action 'ok))
  236.         (pack t-lab e :side "left" :padx "3m" :pady "3m")
  237.  
  238.         (button b-ok :text "Ok" :command '(set! wtour-action "ok"))
  239.         (frame b-default :relief "sunken" :bd 1)
  240.         (raise b-ok b-default)
  241.         (pack b-default :in w-bot :side "left" :expand "1"
  242.           :padx "3m" :pady "2m")
  243.         (pack b-ok :in b-default :padx "2m" 
  244.           :ipadx "2m" :ipady "1m")
  245.         (button b-cancel :text "Cancel" :command 
  246.             '(set! wtour-action "cancel"))
  247.         (pack b-cancel :side "left" :padx "3m" :pady "3m"
  248.           :ipadx "2m" :ipady "1m" :expand "yes")
  249.         (centerwindow w)
  250.         (focus e)
  251.         (tkwait 'variable 'wtour-action)
  252.         (destroy w)
  253.         wtour-action))))))
  254.  
  255. ;; Write the edit buffer to the specified file
  256.  
  257. (define (write-file fname)
  258.   (with-output-to-file fname
  259.     (lambda ()
  260.       (format #t "~A" (wtour-txt 'get "1.0" "end")))))
  261.  
  262. ;; ignoring file existence check (update)
  263.  
  264. (define (do-save-file fname)
  265.   (write-file fname))
  266.  
  267. (define (do-new)
  268.   (wtour-txt 'delete "1.0" "end")
  269.   (apply-changes))
  270.  
  271. (define (do-saveas)
  272.   (if (equal? (mkentryquery ".dialog" 
  273.              "Enter save file name:" 'wtour-filename) "ok")
  274.       (do-save-file wtour-filename)))
  275.  
  276. (define (do-open-file fname)
  277.   (with-input-from-file fname
  278.     (lambda ()
  279.       (wtour-txt 'delete "1.0" "end")
  280.       (do ((l (read-line) (read-line)))
  281.       ((eof-object? l))
  282.     (wtour-txt 'insert "end" l)
  283.     (wtour-txt 'insert "end" "\n"))
  284.       (wtour-txt 'mark 'set 'insert "1.0")))
  285.     (apply-changes))
  286.  
  287. (define (do-open)
  288.   (if (equal? (mkentryquery ".dialog" 
  289.                 "Enter file name to load:" 'wtour-filename) "ok")
  290.       (do-open-file wtour-filename)))
  291.  
  292.  
  293. ;; need to do it recursively! (look at X selection to see why it wont work)
  294. (define (fix-widget-names l)
  295.   (map
  296.     (lambda (x)
  297.       (cond
  298.        ((symbol? x) (let ([y (symbol->string x)])
  299.               (if (eq? (string-ref y 0) #\.)
  300.               (string->symbol (string-append ".wtour-wdemo" y))
  301.               x)))
  302.        ((string? x) (if (eq? (string-ref x 0) #\.)
  303.             (string-append ".wtour-wdemo" x)
  304.             x))
  305.        ((list? x) (fix-widget-names x))            
  306.        (else        x)))
  307.     l))
  308.  
  309. ;; mopping up the demo window prior to loading the next lesson
  310. ;; or applying the changes to the demo window.
  311.  
  312. (define (clear-up-wtour-wdemo)
  313.   (let ([wtour-wdemo-child (winfo 'children .wtour-wdemo)])
  314.     (if (not (null? wtour-wdemo-child))
  315.     (if (list? wtour-wdemo-child)
  316.         (map (lambda (w) 
  317.            (destroy w))
  318.          wtour-wdemo-child)
  319.         (destroy wtour-wdemo-child)))))
  320.  
  321. ;; apply the changes to the demo window
  322. (define (apply-changes)
  323.   (clear-up-wtour-wdemo)
  324.   (let ([x (wtour-txt 'get "1.0" "end")])
  325.     (with-input-from-string
  326.     x
  327.       (lambda ()
  328.     (let loop ([y (read)])
  329.       (if (not (eof-object? y))
  330.           (let ([z (fix-widget-names y)])
  331.         (eval z)
  332.         (loop (read)))))))))
  333.         
  334.  
  335. (define-macro (add1! var)
  336.   `(set! ,var (+ 1 ,var)))
  337.  
  338. (define-macro (incr! var val)
  339.   `(set! ,var (+ ,var ,val)))
  340.  
  341. (define-macro (add-to-menu-assoc item)
  342.   `(set! wtour-menus (cons ,item wtour-menus)))
  343.  
  344.  
  345. (define-macro (add-to-menu-list item)
  346.   `(set! wtour-menu-bar (cons ,item wtour-menu-bar)))
  347.  
  348. ;; Define a new lesson
  349.  
  350. (define (lesson mname name file)
  351.   (vector-set! wtour-lessons wtour-nlessons file)
  352.   (let ([mb (assoc mname wtour-menus)] 
  353.     [first (assoc mname wtour-menus)])
  354.     (if (not first)
  355.     (begin
  356.       (set! mb (& (& wtour-mframe ".") wtour-nlessons))
  357.       (menubutton mb :text mname :menu (& mb ".menu"))
  358.       (pack mb :side "left")
  359.       (add-to-menu-assoc (cons mname (menu (& mb ".menu"))))
  360.       (add-to-menu-list mb)))
  361.     (if (not (equal? name ""))
  362.     (begin
  363.       ((eval (cdr (assoc mname wtour-menus))) 'add 'command :label name
  364.                         :command `(set-lesson ,wtour-nlessons))
  365.       (add1! wtour-nlessons))
  366.       ((eval (cdr mb)) 'add "separator"))))
  367.  
  368.  
  369. ;; set the current lesson
  370. (define (set-lesson num)
  371.   (set! wtour-curlesson num)
  372.   (do-open-file (& wtour-lessondir "/" (vector-ref wtour-lessons num))))
  373.  
  374. (define (do-warning-dialog str)
  375.   (stk:make-dialog :window ".info" :title "Warning"
  376.            :text str
  377.            :bitmap ""
  378.            :grab #t
  379.            :defaults 0
  380.            :buttons (list (list "Cancel" (lambda () #f)))))
  381.  
  382. ;; adjust the current lesson by some increment
  383.  
  384. (define (adjust-lesson i)
  385.   (incr! wtour-curlesson i)
  386.   (if (>= wtour-curlesson wtour-nlessons)
  387.       (begin
  388.     (do-warning-dialog "That was the last lesson")
  389.     (set! wtour-curlesson (- wtour-nlessons 1)))
  390.       (if (< wtour-curlesson 0)
  391.       (begin
  392.         (do-warning-dialog "That was the first lesson")
  393.         (set! wtour-curlesson 0))))
  394.   (set-lesson wtour-curlesson))
  395.  
  396.  
  397. ;; clean up and exit
  398.  
  399. (define (do-exit)
  400.   (exit))
  401.       
  402. (set-font "-*-courier-medium-r-*-*-12-*-*-*-*-*-*-*")
  403.          
  404. (set! wtour-nlessons 0)
  405. (load (& wtour-lessondir "/index"))
  406. (set-lesson 0)
  407.